home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / pcl-env.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1992-07-09  |  63.5 KB  |  1,632 lines
  1. ;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.com)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27. ;;; Xerox-Lisp specific environment hacking for PCL
  28.  
  29. (in-package "PCL")
  30.  
  31. ;; 
  32. ;; Protect the Corporation
  33. ;; 
  34. (eval-when (eval load)
  35.   (format *terminal-io*
  36.     "~&;PCL-ENV Copyright (c) 1987, 1988, 1989, by ~
  37.         Xerox Corporation.  All rights reserved.~%"))
  38.  
  39.  
  40. ;;; Make funcallable instances (FINs) print by calling print-object.
  41.  
  42. (eval-when (eval load)
  43.   (il:defprint 'il:compiled-closure 'il:print-closure))
  44.  
  45. (defun il:print-closure (x &optional stream depth)
  46.   ;; See the IRM, section 25.3.3.  Unfortunatly, that documentation is
  47.   ;; not correct.  In particular, it makes no mention of the third argument.
  48.   (cond ((not (funcallable-instance-p x))
  49.      ;; IL:\CCLOSURE.DEFPRINT is the orginal system function for
  50.      ;; printing closures
  51.      (il:\\cclosure.defprint x stream))
  52.     ((streamp stream)
  53.      ;; Use the standard PCL printing method, then return T to tell
  54.      ;; the printer that we have done the printing ourselves.
  55.      (print-object x stream)
  56.      t)
  57.     (t 
  58.      ;; Internal printing (again, see the IRM section 25.3.3). 
  59.      ;; Return a list containing the string of characters that
  60.      ;; would be printed, if the object were being printed for
  61.      ;; real.
  62.      (with-output-to-string (stream)
  63.        (list (print-object x stream))))))
  64.  
  65.  
  66. ;;; Naming methods
  67.  
  68. (defun gf-named (gf-name)
  69.   (let ((spec (cond ((symbolp gf-name) gf-name)
  70.             ((and (consp gf-name)
  71.               (eq (first gf-name) 'setf)
  72.               (symbolp (second gf-name))
  73.               (null (cddr gf-name)))
  74.              (get-setf-function-name (second gf-name)))
  75.             (t nil))))
  76.     (if (and (fboundp spec)
  77.          (generic-function-p (symbol-function spec)))
  78.     (symbol-function spec)
  79.     nil)))
  80.  
  81. (defun generic-function-method-names (gf-name hasdefp)
  82.   (if hasdefp
  83.       (let ((names nil))
  84.         (maphash #'(lambda (key value)
  85.                      (declare (ignore value))
  86.                      (when (and (consp key) (eql (car key) gf-name))
  87.                        (pushnew key names)))
  88.                  (gethash 'methods xcl:*definition-hash-table*))
  89.         names)
  90.       (let ((gf (gf-named gf-name)))
  91.         (when gf
  92.           (mapcar #'full-method-name (generic-function-methods gf))))))
  93.  
  94. (defun full-method-name (method)
  95.   "Return the full name of the method"
  96.   (let ((specializers (mapcar #'(lambda (x)
  97.                           (cond ((eq x 't) t)
  98.                                 ((consp x) x)
  99.                                 (t (class-name x))))
  100.                (method-type-specifiers method))))
  101.     ;; Now go through some hair to make sure that specializer is
  102.     ;; really right.  Once PCL returns the right value for
  103.     ;; specializers this can be taken out.
  104.     (let* ((arglist (method-arglist method))
  105.        (number-required (or (position-if
  106.                   #'(lambda (x) (member x lambda-list-keywords))
  107.                   arglist)
  108.                 (length arglist)))
  109.        (diff (- number-required (length specializers))))
  110.       (when (> diff 0)
  111.     (setq specializers (nconc (copy-list specializers)
  112.                   (make-list diff :initial-element 't)))))
  113.     (make-full-method-name (generic-function-name
  114.                    (method-generic-function method))
  115.                (method-qualifiers method)
  116.                specializers)))
  117.  
  118. (defun make-full-method-name (generic-function-name qualifiers arg-types)
  119.   "Return the full name of a method, given the generic-function name, the method
  120. qualifiers, and the arg-types"
  121.   ;; The name of the method is:
  122.   ;;      (<generic-function-name> <qualifier-1> .. 
  123.   ;;         (<arg-specializer-1>..))
  124.   (labels ((remove-trailing-ts (l)
  125.          (if (null l)
  126.          nil
  127.          (let ((tail (remove-trailing-ts (cdr l))))
  128.            (if (null tail)
  129.                (if (eq (car l) 't)
  130.                nil
  131.                (list (car l)))
  132.                (if (eq l tail)
  133.                l
  134.                (cons (car l) tail)))))))
  135.     `(,generic-function-name ,@qualifiers
  136.       ,(remove-trailing-ts arg-types))))
  137.  
  138. (defun parse-full-method-name (method-name)
  139.   "Parse the method name, returning the gf-name, the qualifiers, and the
  140. arg-types."
  141.   (values (first method-name)
  142.       (butlast (rest method-name))
  143.       (car (last method-name))))
  144.  
  145. (defun prompt-for-full-method-name (gf-name &optional has-def-p)
  146.   "Prompt the user for the full name of a method on the given generic function name"
  147.   (let ((method-names (generic-function-method-names gf-name has-def-p)))
  148.     (cond ((null method-names)
  149.        nil)
  150.       ((null (cdr method-names))
  151.        (car method-names))
  152.       (t (il:menu
  153.           (il:create
  154.            il:menu il:items il:_    ;If HAS-DEF-P, include only
  155.                     ; those methods that have a
  156.                     ; symbolic def'n that we can
  157.                     ; find
  158.            (remove-if #'null
  159.               (mapcar #'(lambda (m)
  160.                       (if (or (not has-def-p)
  161.                           (il:hasdef m 'methods))
  162.                       `(,(with-output-to-string (s)
  163.                            (dolist (x m)
  164.                          (format s "~A " x))
  165.                            s)
  166.                         ',m)
  167.                       nil))
  168.                   method-names))
  169.            il:title il:_ "Which method?"))))))
  170.  
  171.  
  172. ;;; Converting generic defining macros into DEFDEFINER macros
  173.  
  174. (defmacro make-defdefiner (definer-name definer-type type-description &body 
  175.                     definer-options)
  176.   "Make the DEFINER-NAME use DEFDEFINER, defining items of type DEFINER-TYPE"
  177.   (let ((old-definer-macro-name (intern (string-append definer-name
  178.                                " old definition")
  179.                     (symbol-package definer-name)))
  180.     (old-definer-macro-expander (intern (string-append definer-name 
  181.                                " old expander")
  182.                         (symbol-package definer-name))))
  183.     `(progn 
  184.       ;; First, move the current defining function off to some safe
  185.       ;; place
  186.       (unmake-defdefiner ',definer-name)
  187.       (cond ((not (fboundp ',definer-name))
  188.          (error "~A has no definition!" ',definer-name))
  189.         ((fboundp ',old-definer-macro-name))
  190.         ((macro-function ',definer-name)
  191.                     ; We have to move the macro
  192.                     ; expansion function as well,
  193.                     ; so it won't get clobbered
  194.                     ; when the original macro is
  195.                     ; redefined.  See AR 7410.
  196.          (let* ((expansion-function (macro-function ',definer-name)))
  197.            (setf (symbol-function ',old-definer-macro-expander)
  198.              (loop (if (symbolp expansion-function)
  199.                    (setq expansion-function
  200.                      (symbol-function expansion-function))
  201.                    (return expansion-function))))
  202.            (setf (macro-function ',old-definer-macro-name)
  203.              ',old-definer-macro-expander)
  204.            (setf (get ',definer-name 'make-defdefiner) expansion-function)))
  205.         (t (error "~A does not name a macro." ',definer-name)))
  206.       ;; Make sure the type is defined
  207.       (xcl:def-define-type ,definer-type ,type-description)
  208.       ;; Now redefine the definer, using DEFEDFINER and the original def'n
  209.       (xcl:defdefiner ,(if definer-options
  210.                (cons definer-name definer-options)
  211.                definer-name)
  212.       ,definer-type    (&body b) `(,',old-definer-macro-name ,@,'b)))))
  213.  
  214. (defun unmake-defdefiner (definer-name)
  215.   (let ((old-expander (get definer-name 'make-defdefiner)))
  216.     (when old-expander
  217.       (setf (macro-function definer-name old-expander))
  218.       (remprop definer-name 'make-defdefiner))))
  219.  
  220.  
  221. ;;; For tricking ED into being able to use just the generic-function-name
  222. ;;; instead of the full method name
  223.  
  224. (defun source-manager-method-edit-fn (name type source editcoms options)
  225.   "Edit a method of the given name"
  226.   (let ((full-name (if (gf-named name)
  227.                     ;If given the name of a
  228.                     ; generic-function, try to get
  229.                     ; the full method name
  230.                (prompt-for-full-method-name name t)
  231.                     ; Otherwise it should name the
  232.                     ; method
  233.                name)))
  234.     (when (not (null full-name))
  235.       (il:default.editdef full-name type source editcoms options))
  236.     (or full-name name)))        ;Return the name
  237.  
  238. (defun source-manager-method-hasdef-fn (name type &optional source)
  239.   "Is there a method defined with the given name?"
  240.   (cond ((not (eq type 'methods)) nil)
  241.     ((or (symbolp name)
  242.          (and (consp name)
  243.           (eq (first name) 'setf)
  244.           (symbolp (second name))
  245.           (null (cddr name))))
  246.      ;; If passed in the name of a generic-function, pretend that
  247.      ;; there is a method by that name if there is a generic function
  248.      ;; by that name, and there is a method whose source we can find.
  249.      (if (and (not (null (gf-named name)))
  250.           (find-if #'(lambda (m)
  251.                    (il:hasdef m type source))
  252.                (generic-function-method-names name t)))
  253.          name
  254.          nil))
  255.     ((and (consp name) (>= (length name) 2))
  256.      ;; Standard methods are named (gf-name {qualifiers}* ({specializers}*))
  257.      (when (il:getdef name type source '(il:nocopy il:noerror))
  258.        name))
  259.     (t
  260.      ;; Nothing else can name a method
  261.      nil)))
  262.  
  263. ;;; Initialize the PCL env
  264.  
  265. (defun initialize-pcl-env nil
  266.   "Initialize the Xerox PCL environment" 
  267.   ;; Set up SourceManager DEFDEFINERS for classes and methods.
  268.   ;;
  269.   ;; Make sure to define methods before classes, so that (IL:FILES?) will build
  270.   ;; filecoms that have classes before methods. 
  271.   (unless (il:hasdef 'methods 'il:filepkgtype)
  272.     (make-defdefiner defmethod methods "methods"
  273.              (:name (lambda (form)
  274.                   (multiple-value-bind (name qualifiers arglist)
  275.                   (parse-defmethod (cdr form))
  276.                 (make-full-method-name name qualifiers
  277.                     (extract-specializer-names
  278.                     arglist)))))
  279.              (:undefiner
  280.               (lambda (method-name)
  281.             (multiple-value-bind
  282.                   (name qualifiers arg-types)
  283.                 (parse-full-method-name method-name)
  284.               (let* ((gf (gf-named name))
  285.                  (method (when gf
  286.                        (get-method gf qualifiers
  287.                                (mapcar #'find-class 
  288.                                    arg-types)))))
  289.                 (when method (remove-method gf method))))))))
  290.   ;; Include support for DEFGENERIC, if that is defined
  291.   (unless (or (not (fboundp 'defgeneric))
  292.           (il:hasdef 'generic-functions 'il:filepkgtype))
  293.     (make-defdefiner defgeneric generic-functions "generic-function definitions"))
  294.   ;; DEFCLASS FileManager stuff
  295.   (unless (il:hasdef 'classes 'il:filepkgtype)
  296.     (make-defdefiner defclass classes "class definitions"
  297.              (:undefiner (lambda (name)
  298.                    (when (find-class name t)
  299.                      (setf (find-class name) nil)))))
  300.     ;; CLASSES "include" TYPES.
  301.     (il:filepkgcom 'classes 'il:contents
  302.            #'(lambda (com name type &optional reason)
  303.                (declare (ignore name reason))
  304.                (if (member type '(il:types classes) :test #'eq)
  305.                (cdr com)
  306.                nil))))
  307.   ;; Set up the hooks so that ED can be handed the name of a generic function,
  308.   ;; and end up editing a method instead
  309.   (il:filepkgtype 'methods 'il:editdef 'source-manager-method-edit-fn
  310.           'il:hasdef 'source-manager-method-hasdef-fn)
  311.   ;; Set up the inspect macro.  The right way to do this is to
  312.   ;; (ENSURE-GENERIC-FUNCTION 'IL:INSPECT...), but for now...
  313.   (push '((il:function pcl-object-p) . \\internal-inspect-object)
  314.     il:inspectmacros)
  315.   ;; Unmark any SourceManager changes caused by this loadup
  316.   (dolist (com (il:filepkgchanges))
  317.     (dolist (name (cdr com))
  318.       (when (and (symbolp name)
  319.          (eq (symbol-package name) (find-package "PCL")))
  320.     (il:unmarkaschanged name (car com))))))
  321.  
  322. (eval-when (eval load)
  323.   (initialize-pcl-env))
  324.  
  325.  
  326. ;;; Inspecting PCL objects
  327.  
  328. (defun pcl-object-p (x)
  329.   "Is the datum a PCL object?"
  330.   (or (std-instance-p x)
  331.       (fsc-instance-p x)
  332.       #+pcl-user-instances
  333.       (user-instance-p x)))
  334.  
  335. (defun \\internal-inspect-object (x type where)
  336.   (inspect-object x type where))
  337.  
  338. (defun \\internal-inspect-slot-names (x)
  339.   (inspect-slot-names x))
  340.  
  341. (defun \\internal-inspect-slot-value (x slot-name)
  342.   (inspect-slot-value x slot-name))
  343.  
  344. (defun \\internal-inspect-setf-slot-value (x slot-name value)
  345.   (inspect-setf-slot-value x slot-name value))
  346.  
  347. (defun \\internal-inspect-slot-name-command (slot-name x window)
  348.   (inspect-slot-name-command slot-name x window))
  349.  
  350. (defun \\internal-inspect-title (x y)
  351.   (inspect-title x y))
  352.  
  353. (defmethod inspect-object (x type where)
  354.   "Open an insect window on the object x"
  355.   (il:inspectw.create x '\\internal-inspect-slot-names
  356.               '\\internal-inspect-slot-value
  357.               '\\internal-inspect-setf-slot-value
  358.               '\\internal-inspect-slot-name-command nil nil 
  359.               '\\internal-inspect-title nil where
  360.               #'(lambda (n v)        ;Same effect as NIL, but avoids bug in
  361.           (declare (ignore v))    ; INSPECTW.CREATE
  362.           n)))
  363.  
  364. (defmethod inspect-slot-names (x)
  365.   "Return a list of names of slots of the object that should be shown in the
  366. inspector"
  367.   (mapcar #'(lambda (slotd) (slot-value slotd 'name))
  368.       (slots-to-inspect (class-of x) x)))
  369.  
  370. (defmethod inspect-slot-value (x slot-name)
  371.   (cond ((not (slot-exists-p x slot-name)) "** no such slot **")
  372.     ((not (slot-boundp x slot-name)) "** slot not bound **")
  373.     (t (slot-value x slot-name))))
  374.  
  375. (defmethod inspect-setf-slot-value (x slot-name value)
  376.   "Used by the inspector to set the value fo a slot"
  377.   ;; Make this UNDO-able
  378.   (il:undosave `(inspect-setf-slot-value ,x ,slot-name
  379.          ,(slot-value x slot-name)))
  380.   ;; Then change the value
  381.   (setf (slot-value x slot-name) value))
  382.  
  383. (defmethod inspect-slot-name-command (slot-name x window)
  384.   "Allows the user to select a menu item to change a slot value in an inspect
  385. window"
  386.   ;; This code is a very slightly hacked version of the system function
  387.   ;; DEFAULT.INSPECTW.PROPCOMMANDFN.  We have to do this because the
  388.   ;; standard version makes some nasty assumptions about
  389.   ;; structure-objects that are not true for PCL objects.
  390.   (declare (special il:|SetPropertyMenu|))
  391.   (case (il:menu (cond ((typep il:|SetPropertyMenu| 'il:menu)
  392.             il:|SetPropertyMenu|)
  393.                (t (il:setq il:|SetPropertyMenu|
  394.                    (il:|create| il:menu il:items il:_
  395.                        '((set 'set 
  396.                       "Allows a new value to be entered"
  397.                       )))))))
  398.     (set 
  399.      ;; The user want to set the value
  400.      (il:ersetq (prog ((il:oldvalueitem (il:itemofpropertyvalue slot-name 
  401.                                 window))
  402.                il:newvalue il:pwindow)
  403.            (il:ttydisplaystream (il:setq il:pwindow
  404.                          (il:getpromptwindow window 3)))
  405.            (il:clearbuf t t)
  406.            (il:resetlst
  407.             (il:resetsave (il:\\itemw.flipitem il:oldvalueitem window)
  408.                   (list 'il:\\itemw.flipitem 
  409.                     il:oldvalueitem window))
  410.             (il:resetsave (il:tty.process (il:this.process)))
  411.             (il:resetsave (il:printlevel 4 3))
  412.             (il:|printout| t "Enter the new " 
  413.             slot-name " for " x t 
  414.             "The expression read will be EVALuated."
  415.             t "> ")
  416.             (il:setq il:newvalue (il:lispx (il:lispxread t t)
  417.                            '>))
  418.                     ; clear tty buffer because it
  419.                     ; sometimes has stuff left.
  420.             (il:clearbuf t t))
  421.            (il:closew il:pwindow)
  422.            (return (il:inspectw.replace window slot-name il:newvalue)))))))
  423.  
  424. (defmethod inspect-title (x window)
  425.   "Return the title to use in an inspect window viewing x"
  426.   (format nil "Inspecting a ~A" (class-name (class-of x))))
  427.  
  428. (defmethod inspect-title ((x standard-class) window)
  429.   (format nil "Inspecting the class ~A" (class-name x)))
  430.  
  431.  
  432. ;;;  Debugger support for PCL
  433.  
  434.  
  435. (il:filesload pcl-env-internal)
  436.  
  437. ;; Non-PCL specific changes to the debugger
  438.  
  439. ;; Redefining the standard INTERESTING-FRAME-P function.  Now functions can be
  440. ;; declared uninteresting to BT by giving them an XCL::UNINTERESTINGP
  441. ;; property.
  442.  
  443. (dolist (fn '(si::*unwind-protect* il:*env*
  444.           evalhook xcl::nohook xcl::undohook
  445.           xcl::execa0001 xcl::execa0001a0002
  446.           xcl::|interpret-UNDOABLY|
  447.           cl::|interpret-IF| cl::|interpret-FLET|
  448.           cl::|interpret-LET| cl::|interpret-LETA0001|
  449.           cl::|interpret-BLOCK| cl::|interpret-BLOCKA0001|
  450.           il:do-event il:eval-input
  451.           apply t))
  452.   (setf (get fn 'xcl::uninterestingp) t))
  453.  
  454. (defun xcl::interesting-frame-p (xcl::pos &optional xcl::interpflg)
  455.   "Return TRUE iff the frame should be visible for a short backtrace."
  456.   (declare (special il:openfns))
  457.   (let ((xcl::name (if (il:stackp xcl::pos) (il:stkname xcl::pos) xcl::pos)))
  458.     (typecase xcl::name
  459.       (symbol (case xcl::name
  460.         (il:*env*
  461.          ;; *ENV* is used by ENVEVAL etc.
  462.          nil)
  463.         (il:errorset
  464.          (or (<= (il:stknargs xcl::pos) 1)
  465.              (not (eq (il:stkarg 2 xcl::pos nil)
  466.                   'il:internal))))
  467.         (il:eval
  468.          (or (<= (il:stknargs xcl::pos) 1)
  469.              (not (eq (il:stkarg 2 xcl::pos nil)
  470.                   'xcl::internal))))
  471.         (il:apply
  472.          (or (<= (il:stknargs xcl::pos) 2)
  473.              (not (il:stkarg 3 xcl::pos nil))))
  474.         (otherwise
  475.          (cond ((get xcl::name 'xcl::uninterestingp)
  476.             ;; Explicitly declared uninteresting.
  477.             nil)
  478.                ((eq (il:chcon1 xcl::name) (char-code #\\))
  479.             ;; Implicitly declared uninteresting by starting the
  480.             ;; name with a "\".
  481.             nil)
  482.                ((or (member xcl::name il:openfns :test #'eq)
  483.                 (eq xcl::name 'funcall))
  484.             ;;The function won't be seen when compiled, so only show
  485.             ;;it if INTERPFLG it true
  486.             xcl::interpflg)
  487.                (t 
  488.             ;; Interesting by default.
  489.             t)))))
  490.        (cons (case (car xcl::name)
  491.            (:broken t)
  492.            (otherwise nil)))
  493.        (otherwise nil))))
  494.  
  495. (setq il:*short-backtrace-filter* 'xcl::interesting-frame-p)
  496.  
  497.  
  498. (eval-when (eval compile)
  499.   (il:record il:bkmenuitem (il:label (il:bkmenuinfo il:frame-name))))
  500.  
  501.  
  502. ;;  Change the frame inspector to open up lexical environments
  503.  
  504.   ;; Since the DEFSTRUCT is going to build the accessors in the package that is
  505.   ;; current at read-time, and we want the accessors to reside in the IL
  506.   ;; package, we have got to make sure that the defstruct happens when the
  507.   ;; package is IL.
  508.  
  509. (in-package "IL")
  510.  
  511. (cl:defstruct (frame-prop-name (:type cl:list))
  512.   (label-fn 'nill)
  513.   (value-fn
  514.    (function
  515.     (lambda (prop-name framespec)
  516.      (frame-prop-name-data prop-name))))
  517.   (setf-fn 'nill)
  518.   (inspect-fn
  519.    (function
  520.     (lambda (value prop-name framespec window)
  521.      (default.inspectw.valuecommandfn value prop-name (car framespec) window))))
  522.   (data nil))
  523.  
  524. (cl:in-package "PCL")
  525.  
  526. (defun il:debugger-stack-frame-prop-names (il:framespec) 
  527.   ;; Frame prop-names are structures of the form
  528.   ;; (LABEL-FN VALUE-FN SETF-FN EDIT-FN DATA)
  529.   (let ((il:pos (car il:framespec))
  530.     (il:backtrace-item (cadr il:framespec)))
  531.     (il:if (eq 'eval (il:stkname il:pos))
  532.      il:then
  533.      (let ((il:expression (il:stkarg 1 il:pos))
  534.        (il:environment (il:stkarg 2 il:pos)))
  535.        `(,(il:make-frame-prop-name :inspect-fn
  536.        (il:function
  537.         (il:lambda (il:value il:prop-name il:framespec il:window)
  538.           (il:inspect/as/function il:value (car il:framespec) il:window)))
  539.        :data il:expression)
  540.      ,(il:make-frame-prop-name :data "ENVIRONMENT")
  541.      ,@(il:for il:aspect il:in
  542.         `((,(and il:environment (il:environment-vars il:environment))
  543.            "vars")
  544.           (,(and il:environment (il:environment-functions il:environment))
  545.            "functions")
  546.           (,(and il:environment (il:environment-blocks il:environment))
  547.            "blocks")
  548.           (,(and il:environment (il:environment-tagbodies il:environment))
  549.            "tag bodies"))
  550.         il:bind il:group-name il:p-list
  551.         il:eachtime (il:setq il:group-name (cadr il:aspect))
  552.                     (il:setq il:p-list (car il:aspect))
  553.         il:when (not (null il:p-list))
  554.         il:join
  555.         `(,(il:make-frame-prop-name :data il:group-name)
  556.           ,@(il:for il:p il:on il:p-list il:by cddr il:collect
  557.          (il:make-frame-prop-name :label-fn
  558.           (il:function (il:lambda (il:prop-name il:framespec)
  559.                  (car (il:frame-prop-name-data il:prop-name))))
  560.           :value-fn
  561.           (il:function (il:lambda (il:prop-name il:framespec)
  562.                  (cadr (il:frame-prop-name-data il:prop-name))))
  563.           :setf-fn
  564.           (il:function (il:lambda (il:prop-name il:framespec il:new-value)
  565.                  (il:change (cadr (il:frame-prop-name-data
  566.                            il:prop-name))
  567.                         il:new-value)))
  568.           :data il:p))))))
  569.      il:else
  570.      (flet ((il:build-name (&key il:arg-name il:arg-number)
  571.           (il:make-frame-prop-name :label-fn
  572.           (il:function (il:lambda (il:prop-name il:framespec)
  573.                  (car (il:frame-prop-name-data il:prop-name))))
  574.           :value-fn
  575.           (il:function (il:lambda (il:prop-name il:framespec)
  576.                  (il:stkarg (cadr (il:frame-prop-name-data
  577.                            il:prop-name))
  578.                         (car il:framespec))))
  579.           :setf-fn
  580.           (il:function (il:lambda (il:prop-name il:framespec il:new-value)
  581.                  (il:setstkarg (cadr (il:frame-prop-name-data
  582.                               il:prop-name))
  583.                            (car il:framespec)
  584.                            il:new-value)))
  585.           :data
  586.           (list il:arg-name il:arg-number))))
  587.        (let ((il:nargs (il:stknargs il:pos t))
  588.          (il:nargs1 (il:stknargs il:pos))
  589.          (il:fnname (il:stkname il:pos))
  590.          il:argname
  591.          (il:arglist))
  592.      (and (il:litatom il:fnname)
  593.           (il:ccodep il:fnname)
  594.           (il:setq il:arglist (il:listp (il:smartarglist il:fnname))))
  595.      `(,(il:make-frame-prop-name :inspect-fn
  596.          (il:function (il:lambda (il:value il:prop-name il:framespec
  597.                            il:window)
  598.                 (il:inspect/as/function il:value
  599.                             (car il:framespec)
  600.                             il:window)))
  601.          :data
  602.          (il:fetch (il:bkmenuitem il:frame-name) il:of il:backtrace-item))
  603.        ,@(il:bind il:mode il:for il:i il:from 1 il:to il:nargs1 il:collect
  604.           (progn (il:while (il:fmemb (il:setq il:argname (il:pop il:arglist))
  605.                      lambda-list-keywords)
  606.                    il:do
  607.                    (il:setq il:mode il:argname))
  608.              (il:build-name :arg-name
  609.                     (or (il:stkargname il:i il:pos)
  610.                     ; special
  611.                     (if (case il:mode
  612.                           ((nil &optional) il:argname)
  613.                           (t nil))
  614.                         (string il:argname)
  615.                         (il:concat "arg " (- il:i 1))))
  616.                     :arg-number il:i)))
  617.        ,@(let* ((il:novalue "No value")
  618.             (il:slots (il:for il:pvar il:from 0 il:as il:i il:from
  619.                       (il:add1 il:nargs1)
  620.                       il:to il:nargs il:by 1 il:when
  621.                       (and (il:neq il:novalue (il:stkarg il:i il:pos
  622.                                      il:novalue))
  623.                        (or (il:setq il:argname (il:stkargname
  624.                                     il:i il:pos))
  625.                            (il:setq il:argname (il:concat 
  626.                                     "local " 
  627.                                     il:pvar)))
  628.                        )
  629.                       il:collect
  630.                       (il:build-name :arg-name il:argname 
  631.                              :arg-number il:i))))
  632.                (and il:slots (cons (il:make-frame-prop-name :data "locals")
  633.                                    il:slots)))))))))
  634.  
  635. (defun il:debugger-stack-frame-fetchfn (il:framespec il:prop-name)
  636.   (il:apply* (il:frame-prop-name-value-fn il:prop-name)
  637.          il:prop-name il:framespec))
  638.  
  639. (defun il:debugger-stack-frame-storefn (il:framespec il:prop-name il:newvalue)
  640.   (il:apply* (il:frame-prop-name-setf-fn il:prop-name)
  641.          il:prop-name il:framespec il:newvalue))
  642.  
  643. (defun il:debugger-stack-frame-value-command (il:datum il:prop-name 
  644.                                il:framespec il:window)
  645.   (il:apply* (il:frame-prop-name-inspect-fn il:prop-name)
  646.          il:datum il:prop-name il:framespec il:window))
  647.  
  648. (defun il:debugger-stack-frame-title (il:framespec &optional il:window)
  649.   (declare (ignore il:window))
  650.   (il:concat (il:stkname (car il:framespec)) "  Frame"))
  651.  
  652. (defun il:debugger-stack-frame-property (il:prop-name il:framespec)
  653.   (il:apply* (il:frame-prop-name-label-fn il:prop-name)
  654.          il:prop-name il:framespec))
  655.  
  656. ;; Teaching the debugger that there are other file-manager types that can
  657. ;; appear on the stack
  658.  
  659. (defvar xcl::*function-types* '(il:fns il:functions)
  660.   "Manager types that can appear on the stack")
  661.  
  662. ;; Redefine a couple of system functions to use the above stuff
  663.  
  664. #+Xerox-Lyric
  665. (progn
  666.  
  667. (defun il:attach-backtrace-menu (&optional (il:ttywindow
  668.                         (il:wfromds (il:ttydisplaystream)))
  669.                        il:skip)
  670.   (let ((il:bkmenu (il:|create| il:menu
  671.                il:items il:_
  672.                (il:collect-backtrace-items il:ttywindow il:skip)
  673.                il:whenselectedfn il:_
  674.                (il:function il:backtrace-item-selected)
  675.                il:whenheldfn il:_
  676.                #'(il:lambda (il:item il:menu il:button)
  677.                (declare (ignore il:item il:menu))
  678.                (case il:button
  679.                  (il:left (il:promptprint 
  680.                        "Open a frame inspector on this stack frame"
  681.                        ))
  682.                  (il:middle (il:promptprint 
  683.                      "Inspect/Edit this function"))
  684.                  ))
  685.                il:menuoutlinesize il:_ 0
  686.                il:menufont il:_ il:backtracefont
  687.                il:menucolumns il:_ 1))
  688.     (il:ttyregion (il:windowprop il:ttywindow 'il:region))
  689.     il:btw)
  690.     (cond
  691.       ((il:setq il:btw (il:|for| il:atw il:|in| (il:attachedwindows il:ttywindow)
  692.                il:|when| (and (il:setq il:btw (il:windowprop il:atw 'il:menu))
  693.                       (eql (il:|fetch| (il:menu il:whenselectedfn)
  694.                            il:|of| (car il:btw))
  695.                            (il:function il:backtrace-item-selected)))
  696.                il:|do|                       
  697.                (return il:atw)))       
  698.        (il:deletemenu (car (il:windowprop il:btw 'il:menu))
  699.               nil il:btw)
  700.        (il:windowprop il:btw 'il:extent nil)
  701.        (il:clearw il:btw))
  702.       ((il:setq il:btw (il:createw (il:region-next-to (il:windowprop il:ttywindow 'il:region)
  703.                               (il:widthifwindow (il:imin (il:|fetch| (il:menu 
  704.                                                   il:imagewidth
  705.                                                   )
  706.                                              il:|of| il:bkmenu)
  707.                                          il:|MaxBkMenuWidth|))
  708.                               (il:|fetch| (il:region il:height) il:|of| il:ttyregion
  709.                               )
  710.                               'il:left)))   
  711.        (il:attachwindow il:btw il:ttywindow (cond
  712.                           ((il:igreaterp (il:|fetch| (il:region il:left)
  713.                                  il:|of| (il:windowprop
  714.                                       il:btw
  715.                                       'il:region))
  716.                                  (il:|fetch| (il:region il:left)
  717.                                  il:|of| il:ttyregion))
  718.                            'il:right)
  719.                           (t 'il:left))
  720.             nil
  721.             'il:localclose)
  722.        (il:windowprop il:btw 'il:process (il:windowprop il:ttywindow 'il:process))
  723.  
  724.        ))
  725.     (il:addmenu il:bkmenu il:btw (il:|create| il:_ il:position
  726.                      il:xcoord il:_ 0
  727.                      il:ycoord il:_ (il:idifference (il:windowprop
  728.                                      il:btw
  729.                                      'il:height)
  730.                                     (il:|fetch| (il:menu il:imageheight
  731.                                              ) il:|of| 
  732.                                                il:bkmenu
  733.                                                ))))))
  734.  
  735. (defun il:backtrace-item-selected (il:item il:menu il:button)
  736.   (il:resetlst
  737.    (prog (il:olditem il:ttywindow il:bkpos il:pos il:positions il:framewindow
  738.              (il:framespecn (il:|fetch| (il:bkmenuitem il:bkmenuinfo) il:|of| il:item)
  739.  
  740.                     ))
  741.       (cond
  742.     ((il:setq il:olditem (il:|fetch| (il:menu il:menuuserdata) il:|of| il:menu))
  743.      (il:menudeselect il:olditem il:menu)        
  744.      ))
  745.       (il:setq il:ttywindow (il:windowprop (il:wfrommenu il:menu)
  746.                        'il:mainwindow))
  747.       (il:setq il:bkpos (il:windowprop il:ttywindow 'il:stack-position))
  748.       (il:setq il:pos (il:stknth (- il:framespecn)
  749.                  il:bkpos))
  750.       (let ((il:lp (il:windowprop il:ttywindow 'il:lastpos)))
  751.     (and il:lp (il:stknth 0 il:pos il:lp)))
  752.       (il:menuselect il:item il:menu)                
  753.       (if (eq il:button 'il:middle)
  754.       (progn 
  755.  
  756.  
  757.         (il:resetsave nil (list 'il:relstk il:pos))
  758.         (il:inspect/as/function (il:|fetch| (il:bkmenuitem il:frame-name)
  759.                     il:|of| il:item)
  760.                     il:pos il:ttywindow))
  761.       (progn 
  762.  
  763.  
  764.         (il:setq il:framewindow
  765.              (xcl:with-profile (il:process.eval
  766.                           (il:windowprop il:ttywindow 'il:process)
  767.                           '(let ((il:profile (xcl:copy-profile (xcl:find-profile
  768.                                             "READ-PRINT"))))
  769.                             (setf (xcl::profile-entry-value '
  770.                                xcl:*eval-function* il:profile)
  771.                              xcl:*eval-function*)
  772.                             (xcl:save-profile il:profile))
  773.                           t)
  774.                (il:inspectw.create (list il:pos il:item)
  775.                    'il:debugger-stack-frame-prop-names
  776.                    'il:debugger-stack-frame-fetchfn
  777.                    'il:debugger-stack-frame-storefn nil '
  778.                    il:debugger-stack-frame-value-command nil '
  779.                    il:debugger-stack-frame-title nil (
  780.                                       il:make-frame-inspect-window
  781.                                       il:ttywindow)
  782.                    'il:debugger-stack-frame-property)))
  783.         (cond
  784.           ((not (il:windowprop il:framewindow 'il:mainwindow))
  785.            (il:attachwindow il:framewindow il:ttywindow
  786.                 (cond
  787.                   ((il:igreaterp (il:|fetch| (il:region il:bottom)
  788.                              il:|of| (il:windowprop il:framewindow
  789.                                         'il:region))
  790.                          (il:|fetch| (il:region il:bottom)
  791.                              il:|of| (il:windowprop il:ttywindow 'il:region)))
  792.                    'il:top)
  793.                   (t 'il:bottom))
  794.                 nil
  795.                 'il:localclose)
  796.            (il:windowaddprop il:framewindow 'il:closefn (il:function il:detachwindow
  797.                                      ))))))
  798.       (return))))
  799.  
  800. (defun il:collect-backtrace-items (xcl::tty-window xcl::skip)
  801.    (let* ((xcl::items (cons nil nil))
  802.           (xcl::items-tail xcl::items))
  803.          (macrolet ((xcl::collect-item (xcl::new-item)
  804.                            `(progn (setf (rest xcl::items-tail)
  805.                                          (cons ,xcl::new-item nil))
  806.                                    (pop xcl::items-tail))))
  807.                 (let* ((xcl::filter-fn (cond
  808.                                           ((null xcl::skip)
  809.                                            #'xcl:true)
  810.                                           ((eq xcl::skip t)
  811.                                            il:*short-backtrace-filter*)
  812.                                           (t xcl::skip)))
  813.                        (xcl::top-frame (il:stknth 0 (il:getwindowprop xcl::tty-window '
  814.                                                            il:stack-position)))
  815.                        (xcl::next-frame xcl::top-frame)
  816.                        (xcl::frame-number 0)
  817.                        xcl::interesting-p xcl::last-frame-consumed xcl::use-frame xcl::label)
  818.                       (loop (when (null xcl::next-frame)
  819.                                   (return))
  820.                             (multiple-value-setq (xcl::interesting-p xcl::last-frame-consumed 
  821.                                                         xcl::use-frame xcl::label)
  822.                                    (funcall xcl::filter-fn xcl::next-frame))
  823.                             (when (null xcl::last-frame-consumed)
  824.                                                             
  825.                                 (setf xcl::last-frame-consumed xcl::next-frame))
  826.                             (when xcl::interesting-p        
  827.                                 (when (null xcl::use-frame)
  828.                                       (setf xcl::use-frame xcl::last-frame-consumed))
  829.                                                              
  830.                                 (when (null xcl::label)
  831.                                     (setf xcl::label (il:stkname xcl::use-frame))
  832.                                     (if (member xcl::label '(eval il:eval il:apply apply)
  833.                                                :test
  834.                                                'eq)
  835.                                         (setf xcl::label (il:stkarg 1 xcl::use-frame))))
  836.                                                             
  837.                                 (loop (cond
  838.                                          ((not (typep xcl::next-frame 'il:stackp))
  839.                                           (error "~%Use-frame ~S not found" xcl::use-frame))
  840.                                          ((xcl::stack-eql xcl::next-frame xcl::use-frame)
  841.                                           (return))
  842.                                          (t (incf xcl::frame-number)
  843.                                             (setf xcl::next-frame (il:stknth -1 xcl::next-frame 
  844.                                                                          xcl::next-frame)))))
  845.                                                              
  846.                                 (xcl::collect-item (il:|create| il:bkmenuitem
  847.                                                           il:label il:_ (let ((*print-level* 2)
  848.                                                                               (*print-length* 3)
  849.                                                                               (*print-escape* t)
  850.                                                                               (*print-gensym* t)
  851.                                                                               (*print-pretty* nil)
  852.                                                                               (*print-circle* nil)
  853.                                                                               (*print-radix* 10)
  854.                                                                               (*print-array* nil)
  855.                                                                               (il:*print-structure*
  856.                                                                                nil))
  857.                                                                              (prin1-to-string 
  858.                                                                                     xcl::label))
  859.                                                           il:bkmenuinfo il:_ xcl::frame-number
  860.                                                           il:frame-name il:_ xcl::label)))
  861.                                                              
  862.                             (loop (cond
  863.                                      ((not (typep xcl::next-frame 'il:stackp))
  864.                                       (error "~%Last-frame-consumed ~S not found" 
  865.                                              xcl::last-frame-consumed))
  866.                                      ((prog1 (xcl::stack-eql xcl::next-frame xcl::last-frame-consumed
  867.                                                     )
  868.                                           (incf xcl::frame-number)
  869.                                           (setf xcl::next-frame (il:stknth -1 xcl::next-frame 
  870.                                                              
  871.                                                                        xcl::next-frame)))
  872.                                       (return)))))))
  873.          (rest xcl::items)))
  874.  
  875. )
  876. #+Xerox-Medley
  877. (progn
  878.  
  879. (defun dbg::attach-backtrace-menu (&optional tty-window skip)
  880.   (declare (special il:\\term.ofd il:backtracefont))
  881.   (or tty-window (il:setq tty-window (il:wfromds (il:ttydisplaystream))))
  882.   (prog (btw bkmenu
  883.          (tty-region (il:windowprop tty-window 'il:region))
  884.          ;; And, for the FORMAT below...
  885.          (*print-level* 2)
  886.          (*print-length* 3)
  887.          (*print-escape* t)
  888.          (*print-gensym* t)
  889.          (*print-pretty* nil)
  890.          (*print-circle* nil)
  891.          (*print-radix* 10)
  892.          (*print-array* nil)
  893.          (il:*print-structure* nil))
  894.      (setq bkmenu
  895.        (il:|create| il:menu
  896.            il:items il:_ (dbg::collect-backtrace-items tty-window skip)
  897.            il:whenselectedfn il:_ 'dbg::backtrace-item-selected
  898.            il:menuoutlinesize il:_ 0
  899.            il:menufont il:_ il:backtracefont 
  900.            il:menucolumns il:_ 1
  901.            il:whenheldfn il:_
  902.            #'(il:lambda (item menu button)
  903.            (declare (ignore item menu))
  904.            (case button
  905.              (il:left
  906.               (il:promptprint
  907.                "Open a frame inspector on this stack frame"))
  908.              (il:middle
  909.               (il:promptprint "Inspect/Edit this function"))))))
  910.      (cond ((setq btw
  911.           (dolist (atw  (il:attachedwindows tty-window))
  912.             ;; Test for an attached window that has a backtrace menu in
  913.             ;; it.
  914.             (when (and (setq btw (il:windowprop atw 'il:menu))
  915.                (eq (il:|fetch| (il:menu il:whenselectedfn)
  916.                    il:|of| (car btw))
  917.                    'dbg::backtrace-item-selected))
  918.               (return atw))))
  919.         ;; If there is alread a backtrace window, delete the old menu from
  920.         ;; it.
  921.         (il:deletemenu (car (il:windowprop btw 'il:menu)) nil btw)
  922.         (il:windowprop btw 'il:extent nil)
  923.         (il:clearw btw))
  924.        ((setq btw
  925.           (il:createw (dbg::region-next-to
  926.                    (il:windowprop tty-window 'il:region)
  927.                    (il:widthifwindow
  928.                 (il:imin (il:|fetch| (il:menu il:imagewidth)
  929.                          il:|of| bkmenu)
  930.                      il:|MaxBkMenuWidth|))
  931.                    (il:|fetch| (il:region il:height)
  932.                    il:|of| tty-region)
  933.                    :left)))
  934.                     ; put bt window at left of TTY
  935.                     ; window unless ttywindow is
  936.                     ; near left edge.
  937.         (il:attachwindow btw tty-window
  938.                  (if (il:igreaterp (il:|fetch| (il:region il:left)
  939.                            il:|of|
  940.                            (il:windowprop btw
  941.                                   'il:region))
  942.                            (il:|fetch| (il:region il:left)
  943.                            il:|of| tty-region))
  944.                  'il:right
  945.                  'il:left)
  946.                  nil
  947.                  'il:localclose)
  948.         ;; So that button clicks will switch the TTY
  949.         (il:windowprop btw 'il:process
  950.                (il:windowprop tty-window 'il:process))))
  951.      (il:addmenu bkmenu btw (il:|create| il:position
  952.                 il:xcoord il:_ 0 
  953.                 il:ycoord il:_ (- (il:windowprop btw 'il:height)
  954.                           (il:|fetch| (il:menu 
  955.                                    il:imageheight)
  956.                               il:|of| bkmenu))))
  957.      ;; IL:ADDMENU sets up buttoneventfn for window that we don't
  958.      ;; want.  We want to catch middle button events before the menu
  959.      ;; handler, so that we can pop up edit/inspect menu for the frame
  960.      ;; currently selected.  So replace the buttoneventfn, and can
  961.      ;; nuke the cursorin and cursormoved guys, cause don't need them.
  962.      (il:windowprop btw 'il:buttoneventfn 'dbg::backtrace-menu-buttoneventfn)
  963.      (il:windowprop btw 'il:cursorinfn nil)
  964.      (il:windowprop btw 'il:cursormovedfn nil)))
  965.  
  966. (defun dbg::collect-backtrace-items (tty-window skip)
  967.   (xcl:with-collection
  968.       ;;
  969.       ;; There are a number of possibilities for the values returned by the
  970.       ;; filter-fn.
  971.       ;;
  972.       ;; (1) INTERESTING-P is false, and the other values are all NIL.  This
  973.       ;; is the simple case where the stack frame NEXT-POS should be ignored
  974.       ;; completly, and processing should continue with the next frame.
  975.       ;;
  976.       ;; (2) INTERESTING-P is true, and the other values are all NIL.  This
  977.       ;; is the simple case where the stack frame NEXT-POS should appear in
  978.       ;; the backtrace as is, and processing should continue with the next
  979.       ;; frame.
  980.       ;;
  981.       ;; [Note that these two cases take care of old values of the
  982.       ;; filter-fn.]
  983.       ;;
  984.       ;; (3) INTERESTING-P is false, and LAST-FRAME-CONSUMED is a stack
  985.       ;; frame.  In that case, ignore all stack frames from NEXT-POS to
  986.       ;; LAST-FRAME-CONSUMED, inclusive.
  987.       ;;
  988.       ;; (4) INTERESTING-P is true, and LAST-FRAME-CONSUMED is a stack
  989.       ;; frame.  In this case, the backtrace should include a single entry
  990.       ;; coresponding to the frame USE-FRAME (which defaults to
  991.       ;; LAST-FRAME-CONSUMED), and processing should continue with the next
  992.       ;; frame after LAST-FRAME-CONSUMED.  If LABEL is non-NIL, it will be
  993.       ;; the label that appears in the backtrace menu; otherwise the name of
  994.       ;; USE-FRAME will be used (or the form being EVALed if the frame is an
  995.       ;; EVAL frame).
  996.       ;;
  997.       (let* ((filter (cond ((null skip) #'xcl:true)
  998.                ((eq skip t) il:*short-backtrace-filter*)
  999.                (t skip)))
  1000.          (top-frame (il:stknth 0 (il:getwindowprop tty-window
  1001.                           'dbg::stack-position)))
  1002.          (next-frame top-frame)
  1003.          (frame-number 0)
  1004.          interestingp last-frame-consumed frame-to-use label-to-use)
  1005.     (loop (when (null next-frame) (return))
  1006.           ;; Get the values of INTERSTINGP, LAST-FRAME-CONSUMED,
  1007.           ;; FRAME-TO-USE, and LABEL-TO-USE
  1008.           (multiple-value-setq (interestingp last-frame-consumed 
  1009.                          frame-to-use label-to-use)
  1010.         (funcall filter next-frame))
  1011.           (when (null last-frame-consumed)
  1012.         (setf last-frame-consumed next-frame))
  1013.           (when interestingp
  1014.         (when (null frame-to-use)
  1015.           (setf frame-to-use last-frame-consumed))
  1016.         (when (null label-to-use)
  1017.           (setf label-to-use (il:stkname frame-to-use))
  1018.           (if (member label-to-use '(eval il:eval il:apply apply)
  1019.                   :test 'eq)
  1020.               (setf label-to-use (il:stkarg 1 frame-to-use))))
  1021.  
  1022.         ;; Walk the stack until we find the frame to use
  1023.         (loop (cond ((not (typep next-frame 'il:stackp))
  1024.                  (error "~%Use-frame ~S not found" frame-to-use))
  1025.                 ((xcl::stack-eql next-frame frame-to-use)
  1026.                  (return))
  1027.                 (t (incf frame-number)
  1028.                    (setf next-frame
  1029.                      (il:stknth -1 next-frame next-frame)))))
  1030.  
  1031.         ;; Add the menu item to the list under construction
  1032.         (xcl:collect (il:|create| il:bkmenuitem
  1033.                  il:label il:_ (let ((*print-level* 2)
  1034.                              (*print-length* 3)
  1035.                              (*print-escape* t)
  1036.                              (*print-gensym* t)
  1037.                              (*print-pretty* nil)
  1038.                              (*print-circle* nil)
  1039.                              (*print-radix* 10)
  1040.                              (*print-array* nil)
  1041.                              (il:*print-structure* nil))
  1042.                          (prin1-to-string label-to-use))
  1043.                  il:bkmenuinfo il:_ frame-number
  1044.                  il:frame-name il:_ label-to-use)))
  1045.  
  1046.           ;; Update NEXT-POS
  1047.           (loop (cond ((not (typep next-frame 'il:stackp))
  1048.                (error "~%Last-frame-consumed ~S not found" 
  1049.                   last-frame-consumed))
  1050.               ((prog1
  1051.                    (xcl::stack-eql next-frame last-frame-consumed)
  1052.                  (incf frame-number)
  1053.                  (setf next-frame (il:stknth -1 next-frame
  1054.                              next-frame)))
  1055.                (return))))))))
  1056.  
  1057. (defun dbg::backtrace-menu-buttoneventfn (window &aux menu)
  1058.   (setq menu (car (il:listp (il:windowprop window 'il:menu))))
  1059.   (unless (or (il:lastmousestate il:up) (null menu))
  1060.     (il:totopw window)
  1061.     (cond ((il:lastmousestate il:middle)
  1062.        ;; look for a selected frame in this menu, and then pop up
  1063.        ;; the editor invoke menu for that frame.  don't change the
  1064.        ;; selection, just present the edit menu.
  1065.        (let* ((selection (il:menu.handler menu
  1066.                       (il:windowprop window 'il:dsp)))
  1067.           (tty-window (il:windowprop window 'il:mainwindow))
  1068.           (last-pos (il:windowprop tty-window 'dbg::lastpos)))
  1069.                         
  1070.          ;; don't have to worry about releasing POS because we
  1071.          ;; only look at it here (nobody here hangs on to it)
  1072.          ;; and we will be around for less time than LASTPOS. 
  1073.          ;; The debugger is responsible for releasing LASTPOS.
  1074.          (il:inspect/as/function (cond
  1075.                        ((and selection
  1076.                          (il:|fetch| (il:bkmenuitem il:frame-name)
  1077.                          il:|of| (car selection))))
  1078.                        ((and (symbolp (il:stkname last-pos))
  1079.                          (il:getd (il:stkname last-pos)))
  1080.                     (il:stkname last-pos))
  1081.                        (t 'il:nill))
  1082.                      last-pos tty-window)))
  1083.       (t (let ((selection (il:menu.handler menu
  1084.                        (il:windowprop window 'il:dsp))))
  1085.            (when selection
  1086.          (il:doselecteditem menu (car selection) (cdr selection))))))))
  1087.  
  1088. ;; This function isn't really redefined, but it needs to be recomiled since we
  1089. ;; changed the def'n of the BKMENUITEM record.
  1090.  
  1091. (defun dbg::backtrace-item-selected (item menu button)
  1092.   ;;When a frame name is selected in the backtrace menu, this is the function
  1093.   ;;that gets called.
  1094.   (declare (special il:brkenv) (ignore button))
  1095.   (let* ((frame-spec (il:|fetch| (il:bkmenuitem il:bkmenuinfo) il:|of| item))
  1096.      (tty-window (il:windowprop (il:wfrommenu menu) 'il:mainwindow))
  1097.      (bkpos (il:windowprop tty-window 'dbg::stack-position))
  1098.      (pos (il:stknth (- frame-spec) bkpos)))
  1099.     (let ((lp (il:windowprop tty-window 'dbg::lastpos)))
  1100.       (and lp (il:stknth 0 pos lp)))
  1101.     ;; change the item selected from OLDITEM to ITEM.  Only do this on left
  1102.     ;; buttons now.  Middle just pops up the edit menu, doesn't select. -woz
  1103.     (let ((old-item (il:|fetch| (il:menu il:menuuserdata) il:|of| menu)))
  1104.       (when old-item (il:menudeselect old-item menu))
  1105.       (il:menuselect item menu))
  1106.     ;; Change the lexical environment so it is the one in effect as of this
  1107.     ;; frame.
  1108.     (il:process.eval (il:windowprop tty-window (quote dbg::process))
  1109.            `(setq il:brkenv ',(il:find-lexical-environment pos))
  1110.            t)
  1111.     (let ((frame-window (xcl:with-profile
  1112.                 (il:process.eval (il:windowprop tty-window
  1113.                                 'il:process)
  1114.                        `(let ((profile (xcl:copy-profile
  1115.                             (xcl:find-profile
  1116.                              "READ-PRINT"))))
  1117.                      (setf
  1118.                       (xcl::profile-entry-value
  1119.                        'xcl:*eval-function* profile)
  1120.                       xcl:*eval-function*)
  1121.                      (xcl:save-profile profile))
  1122.                        t)
  1123.               (il:inspectw.create pos
  1124.                       #'(lambda (pos)
  1125.                       (dbg::stack-frame-properties pos t))
  1126.                       'dbg::stack-frame-fetchfn
  1127.                       'dbg::stack-frame-storefn
  1128.                       nil
  1129.                       'dbg::stack-frame-value-command
  1130.                       nil
  1131.                       (format nil "~S  Frame" (il:stkname pos))
  1132.                       nil (dbg::make-frame-inspect-window
  1133.                        tty-window)
  1134.                       'dbg::stack-frame-property))))
  1135.       (when (not (il:windowprop frame-window 'il:mainwindow))
  1136.     (il:attachwindow frame-window tty-window
  1137.              (if (> (il:|fetch| (il:region il:bottom) il:|of|
  1138.                     (il:windowprop frame-window 'il:region))
  1139.                 (il:|fetch| (il:region il:bottom) il:|of|
  1140.                     (il:windowprop tty-window 'il:region)))
  1141.                  'il:top 'il:bottom)
  1142.              nil 'il:localclose)
  1143.     (il:windowaddprop frame-window 'il:closefn 'il:detachwindow)))))
  1144.  
  1145. )                    ;end of Xerox-Medley
  1146.  
  1147. (defun il:select.fns.editor (&optional function)
  1148.     ;; gives the user a menu choice of editors.
  1149.     (il:menu (il:|create| il:menu
  1150.          il:items il:_ (cond ((il:ccodep function)
  1151.                       '((il:|InspectCode| 'il:inspectcode 
  1152.                      "Shows the compiled code.")
  1153.                     (il:|DisplayEdit| 'ed 
  1154.                      "Edit it with the display editor")
  1155.                     (il:|TtyEdit| 'il:ef 
  1156.                      "Edit it with the standard editor")))
  1157.                      ((il:closure-p function)
  1158.                       '((il:|Inspect| 'inspect 
  1159.                      "Inspect this object")))
  1160.                      (t '((il:|DisplayEdit| 'ed 
  1161.                        "Edit it with the display editor")
  1162.                       (il:|TtyEdit| 'il:ef 
  1163.                        "Edit it with the standard editor"))))
  1164.          il:centerflg il:_ t)))
  1165.  
  1166. ;; 
  1167.  
  1168.  
  1169. ;; PCL specific extensions to the debugger
  1170.  
  1171.  
  1172. ;; There are some new things that act as functions, and that we want to be
  1173. ;; able to edit from a backtrace window
  1174.  
  1175. (pushnew 'methods xcl::*function-types*)
  1176.  
  1177. (eval-when (eval compile load)
  1178.   (unless (generic-function-p (symbol-function 'il:inspect/as/function))
  1179.     (make-specializable 'il:inspect/as/function)))
  1180.  
  1181. (defmethod il:inspect/as/function (name stack-pointer debugger-window)
  1182.   ;; Calls an editor on function NAME.  STKP and WINDOW are the stack pointer
  1183.   ;; and window of the break in which this inspect command was called.
  1184.   (declare (ignore debugger-window))
  1185.   (let ((editor (il:select.fns.editor name)))
  1186.     (case editor
  1187.       ((nil) 
  1188.        ;; No editor chosen, so don't do anything
  1189.        nil)
  1190.       (il:inspectcode 
  1191.        ;; Inspect the compiled code
  1192.        (let ((frame (xcl::stack-pointer-frame stack-pointer)))
  1193.      (if (and (il:stackp stack-pointer)
  1194.           (xcl::stack-frame-valid-p frame))
  1195.          (il:inspectcode (let ((code-base (xcl::stack-frame-fn-header frame)))
  1196.                    (cond ((eq (il:\\get-compiled-code-base name)
  1197.                       code-base)
  1198.                       name)
  1199.                      (t 
  1200.                       ;; Function executing in this frame is not
  1201.                       ;; the one in the definition cell of its
  1202.                       ;; name, so fetch the real code.  Have to
  1203.                       ;; pass a CCODEP
  1204.                       (il:make-compiled-closure code-base))))
  1205.                              nil nil nil (xcl::stack-frame-pc frame))
  1206.          (il:inspectcode name))))
  1207.       (ed 
  1208.        ;; Use the standard editor.
  1209.        ;; This used to take care to apply the editor in the debugger
  1210.        ;; process, so forms evaluated in the editor happen in the
  1211.        ;; context of the break.  But that doesn't count for much any
  1212.        ;; more, now that lexical variables are the way to go.  Better to
  1213.        ;; use the LEX debugger command (thank you, Herbie) and
  1214.        ;; shift-select pieces of code from the editor into the debugger
  1215.        ;; window. 
  1216.        (ed name `(,@xcl::*function-types* :display)))
  1217.       (otherwise (funcall editor name)))))
  1218.  
  1219. (defmethod il:inspect/as/function ((name standard-object) stkp window)
  1220.   (when (il:menu (il:|create| il:menu
  1221.              il:items il:_ '(("Inspect" t "Inspect this object"))))
  1222.     (inspect name)))
  1223.  
  1224. (defmethod il:inspect/as/function ((x standard-method) stkp window)
  1225.   (let* ((generic-function-name (slot-value (slot-value x 'generic-function)
  1226.                         'name))
  1227.      (method-name (full-method-name x))
  1228.      (editor (il:select.fns.editor method-name)))
  1229.     (il:allow.button.events)
  1230.     (case editor
  1231.       (ed (ed method-name '(:display methods)))
  1232.       (il:inspectcode (il:inspectcode (slot-value x 'function)))
  1233.       ((nil) nil)
  1234.       (otherwise (funcall editor method-name)))))
  1235.  
  1236. ;; A replacement for the vanilla IL:INTERESTING-FRAME-P so we can see methods
  1237. ;; and generic-functions on the stack.
  1238.  
  1239. (defun interesting-frame-p (stack-pos &optional interp-flag)
  1240.   ;; Return up to four values:  INTERESTING-P LAST-FRAME-CONSUMED USE-FRAME and
  1241.   ;; LABEL.  See the function IL:COLLECT-BACKTRACE-ITEMS for a full description
  1242.   ;; of how these values are used.
  1243.   (labels
  1244.       ((function-matches-frame-p (function frame)
  1245.        "Is the function being called in this frame?"
  1246.        (let* ((frame-name (il:stkname frame))
  1247.           (code-being-run (cond
  1248.                     ((typep frame-name 'il:closure)
  1249.                      frame-name)
  1250.                     ((and (consp frame-name)
  1251.                       (eq 'il:\\interpreter
  1252.                           (xcl::stack-frame-name
  1253.                            (il:\\stackargptr frame))))
  1254.                      frame-name)
  1255.                     (t (xcl::stack-frame-fn-header
  1256.                     (il:\\stackargptr frame))))))
  1257.          (or (eq function code-being-run)
  1258.          (and (typep function 'il:compiled-closure)
  1259.               (eq (xcl::compiled-closure-fnheader function)
  1260.               code-being-run)))))
  1261.        (generic-function-from-frame (frame)
  1262.      "If this the frame of a generic function return the gf, otherwise
  1263.           return NIL."
  1264.      ;; Generic functions are implemented as compiled closures.  On the
  1265.      ;; stack, we only see the fnheader for the the closure.  This could
  1266.      ;; be a discriminator code, or in the default method only case it
  1267.      ;; will be the actual method function.  To tell if this is a generic
  1268.      ;; function frame, we have to check very carefully to see if the
  1269.      ;; right stuff is on the stack.  Specifically, the closure's ccode,
  1270.      ;; and the first local variable has to be a ptrhunk big enough to be
  1271.      ;; a FIN environment, and fin-env-fin of that ptrhunk has to point
  1272.      ;; to a generic function whose ccode and environment match. 
  1273.      (let ((n-args (il:stknargs frame))
  1274.            (env nil)
  1275.            (gf nil))
  1276.        (if (and ;; is there at least one local?
  1277.         (> (il:stknargs frame t) n-args)
  1278.         ;; and does the local contain something that might be
  1279.         ;; the closure environment of a funcallable instance?
  1280.         (setf env (il:stkarg (1+ n-args) frame))
  1281.         ;; and does the local contain something that might be
  1282.         ;; the closure environment of a funcallable instance?
  1283.         (typep env *fin-env-type*)
  1284.         (setf gf (fin-env-fin env))
  1285.         ;; whose fin-env-fin points to a generic function?
  1286.         (generic-function-p gf)
  1287.         ;; whose environment is the same as env?
  1288.         (eq (xcl::compiled-closure-env gf) env)
  1289.         ;; and whose code is the same as the code for this
  1290.         ;; frame? 
  1291.         (function-matches-frame-p gf frame))
  1292.            gf
  1293.            nil))))
  1294.     (let ((frame-name (il:stkname stack-pos)))
  1295.       ;; See if there is a generic-function on the stack at this
  1296.       ;; location.
  1297.       (let ((gf (generic-function-from-frame stack-pos)))
  1298.     (when gf
  1299.       (return-from interesting-frame-p (values t stack-pos stack-pos gf))))
  1300.       ;; See if this is an interpreted method.  The method body is
  1301.       ;; wrapped in a (BLOCK <function-name> ...).  We look for an
  1302.       ;; interpreted call to BLOCK whose block-name is the name of
  1303.       ;; generic-function.
  1304.       (when (and (eq frame-name 'eval)
  1305.          (consp (il:stkarg 1 stack-pos))
  1306.          (eq (first (il:stkarg 1 stack-pos)) 'block)
  1307.          (symbolp (second (il:stkarg 1 stack-pos)))
  1308.          (fboundp (second (il:stkarg 1 stack-pos)))
  1309.          (generic-function-p
  1310.              (symbol-function (second (il:stkarg 1 stack-pos)))))
  1311.     (let* ((form (il:stkarg 1 stack-pos))
  1312.            (block-name (second form))
  1313.            (generic-function (symbol-function block-name))
  1314.            (methods (generic-function-methods (symbol-function block-name))))
  1315.       ;; If this is really a method being called from a
  1316.       ;; generic-function, the g-f should be no more than a
  1317.       ;; few(?) frames up the stack.  Check for the method call
  1318.       ;; by looking for a call to APPLY, where the function
  1319.       ;; being applied is the code in one of the methods.
  1320.       (do ((i 100 (1- i))
  1321.            (previous-pos stack-pos current-pos)
  1322.            (current-pos (il:stknth -1 stack-pos) (il:stknth -1 current-pos))
  1323.            (found-method nil)
  1324.            (method-pos))
  1325.           ((or (null current-pos) (<= i 0)) nil)
  1326.         (cond ((equalp generic-function
  1327.                (generic-function-from-frame current-pos))
  1328.            (if found-method
  1329.                (return-from interesting-frame-p
  1330.              (values t previous-pos method-pos found-method))
  1331.                (return)))
  1332.           (found-method nil)
  1333.           ((eq (il:stkname current-pos) 'apply)
  1334.            (dolist (method methods)
  1335.              (when (memq (il:stkarg 1 current-pos)
  1336.                  (method-cached-functions method))
  1337.                (setq method-pos current-pos)
  1338.                (setq found-method method)
  1339.                (return))))))))
  1340.       ;; Try to handle compiled methods
  1341.       (when (and (symbolp frame-name)
  1342.          (not (fboundp frame-name))
  1343.          (eq (il:chcon1 frame-name)
  1344.              (il:charcode il:\())
  1345.          (or (string-equal "(method " (symbol-name frame-name)
  1346.                   :start2 0 :end2 13)
  1347.              (string-equal "(method " (symbol-name frame-name)
  1348.                   :start2 0 :end2 12)
  1349.              (string-equal "(method " (symbol-name frame-name)
  1350.                   :start2 0 :end2 8)))
  1351.     ;; Looks like a name that PCL consed up.  See if there is a
  1352.     ;; GF nearby up the stack.  If there is, use it to help
  1353.     ;; determine which method we have.
  1354.     (do ((i 30 (1- i))
  1355.          (current-pos (il:stknth -1 stack-pos)
  1356.               (il:stknth -1 current-pos))
  1357.          (gf))
  1358.         ((or (null current-pos)
  1359.          (<= i 0))
  1360.          nil)
  1361.       (setq gf (generic-function-from-frame current-pos))
  1362.       (when gf
  1363.         (dolist (method (generic-function-methods gf))
  1364.           (dolist (function (method-cached-functions method))
  1365.              (when (function-matches-frame-p function stack-pos)
  1366.            (return-from interesting-frame-p
  1367.                         (values t stack-pos stack-pos method)))))
  1368.         (return))))
  1369.       ;; If we haven't already returned, use the default method.
  1370.       (xcl::interesting-frame-p stack-pos interp-flag))))
  1371.  
  1372.  
  1373. (setq il:*short-backtrace-filter* 'interesting-frame-p)
  1374.  
  1375. ;;; Support for undo
  1376.  
  1377.  (defun undoable-setf-slot-value (object slot-name new-value)
  1378.     (if (slot-boundp object slot-name)
  1379.       (il:undosave (list 'undoable-setf-slot-value
  1380.                          object slot-name (slot-value object slot-name)))
  1381.       (il:undosave (list 'slot-makunbound object slot-name)))
  1382.     (setf (slot-value object slot-name) new-value))
  1383.  
  1384.   (setf (get 'slot-value :undoable-setf-inverse) 'undoable-setf-slot-value)
  1385.  
  1386.  
  1387. ;;; Support for ?= and friends
  1388.  
  1389. ;; The arglists for generic-functions are built using gensyms, and don't reflect
  1390. ;; any keywords (they are all included in an &REST arg).  Rather then use the
  1391. ;; arglist in the code, we use the one that PCL kindly keeps in the generic-function.
  1392.  
  1393. (xcl:advise-function 'il:smartarglist
  1394.   '(if (and il:explainflg
  1395.     (symbolp il:fn)
  1396.     (fboundp il:fn)
  1397.     (generic-function-p (symbol-function il:fn)))
  1398.     (generic-function-pretty-arglist (symbol-function il:fn))
  1399.     (xcl:inner))
  1400.   :when :around :priority :last)
  1401.  
  1402. (setf (get 'defclass 'il:argnames)
  1403.       '(nil (class-name (#\{ superclass-name #\} #\*)
  1404.          (#\{ slot-specifier #\} #\*)
  1405.          #\{ slot-option #\} #\*)))
  1406.  
  1407. (setf (get 'defmethod 'il:argnames)
  1408.       '(nil (#\{ name #\| (setf name) #\} #\{ method-qualifier #\} #\*
  1409.          specialized-lambda-list #\{ declaration #\| doc-string #\} #\*
  1410.          #\{ form #\} #\*)))
  1411.  
  1412. ;;; Prettyprinting support, the result of Harley Davis.
  1413.  
  1414. ;; Support the standard Prettyprinter.  This is really minimal right now.  If
  1415. ;; anybody wants to fix this, I'd be happy to include their code.  In fact,
  1416. ;; there is almost no support for Commonlisp in the standard Prettyprinter, so
  1417. ;; the field is wide open to hackers with time on their hands.
  1418.  
  1419.  
  1420. (setf (get 'defmethod :definition-print-template) ;Not quite right, since it
  1421.       '(:name :arglist :body))                  ; doesn't handle qualifiers,
  1422.                                     ; but it will have to do.
  1423.  
  1424. (defun defclass-prettyprint (form)
  1425.   (let ((left (il:dspxposition))
  1426.     (char-width (il:charwidth (il:charcode x) *standard-output*)))
  1427.     (xcl:destructuring-bind (defclass name supers slots . options) form
  1428.       (princ "(")
  1429.       (prin1 defclass)
  1430.       (princ " ")
  1431.       (prin1 name)
  1432.       (princ " ")
  1433.       (if (null supers)
  1434.       (princ "()")            ;Print "()" instead of "nil"
  1435.       (il:sequential.prettyprint (list supers) (il:dspxposition)))
  1436.       (if (null slots)
  1437.       (progn (il:prinendline (+ left (* 4 char-width)) *standard-output*)
  1438.          (princ "()"))
  1439.       (il:sequential.prettyprint (list slots) (+ left (* 4 char-width))))
  1440.       (when options
  1441.     (il:sequential.prettyprint options (+ left (* 2 char-width))))
  1442.       (princ ")")
  1443.       nil)))
  1444.  
  1445. (let ((pprint-macro (assoc 'defclass il:prettyprintmacros)))
  1446.   (if (null pprint-macro)
  1447.       (push (cons 'defclass 'defclass-prettyprint)
  1448.         il:prettyprintmacros)
  1449.       (setf (cdr pprint-macro) 'defclass-prettyprint)))
  1450.  
  1451. (defun binder-prettyprint (form)
  1452.   ;; Prettyprints expressions like MULTIPLE-VALUE-BIND and WITH-SLOTS
  1453.   ;; that are of the form (fn (var ...) form &rest body).
  1454.   ;; This code is far from correct, but it's better than nothing.
  1455.   (if (and (consp form)
  1456.        (not (null (cdddr form))))
  1457.       ;; I have no idea what I'm doing here.  Seems I can copy and edit somebody
  1458.       ;; elses code without understanding it.
  1459.       (let ((body-indent (+ (il:dspxposition)
  1460.                 (* 2 (il:charwidth (il:charcode x)
  1461.                            *standard-output*))))
  1462.         (form-indent (+ (il:dspxposition)
  1463.                 (* 4 (il:charwidth (il:charcode x)
  1464.                            *standard-output*)))))
  1465.     (princ "(")
  1466.     (prin1 (first form))
  1467.     (princ " ")
  1468.     (il:superprint (second form) form nil *standard-output*)
  1469.     (il:sequential.prettyprint (list (third form)) form-indent)
  1470.     (il:sequential.prettyprint (cdddr form) body-indent)
  1471.     (princ ")")
  1472.     nil)                ;Return NIL to indicate that we did
  1473.                     ; the printing
  1474.       t))                ;Return true to use default printing
  1475.  
  1476.  
  1477. (dolist (fn '(multiple-value-bind with-accessors with-slots))
  1478.   (let ((pprint-macro (assoc fn 'il:prettyprintmacros)))
  1479.     (if (null pprint-macro)
  1480.     (push (cons fn 'binder-prettyprint)
  1481.           il:prettyprintmacros)
  1482.     (setf (cdr pprint-macro) 'binder-prettyprint))))
  1483.  
  1484.  
  1485.  
  1486. ;; SEdit has its own prettyprinter, so we need to support that too.  This is due
  1487. ;; to Harley Davis.  Really.
  1488.  
  1489. (push (cons :slot-spec
  1490.         '(((sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1)
  1491.         break sedit::from-indent . 0)
  1492.            (sedit::set-indent . 1)
  1493.            (sedit::next-inline? 1 break sedit::from-indent . 1)
  1494.            (sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1)
  1495.         break sedit::from-indent . 0))
  1496.           ((sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1)
  1497.         break sedit::from-indent . 0)
  1498.            (sedit::set-indent . 1)
  1499.            (sedit::next-inline? 1 break sedit::from-indent . 1)
  1500.            (sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1)
  1501.         break sedit::from-indent . 0))))
  1502.     sedit:*indent-alist*)
  1503.  
  1504. (setf (sedit:get-format :slot-spec)
  1505.       '(:indent :slot-spec :inline t))
  1506.  
  1507. (setf (sedit:get-format :slot-spec-list)
  1508.       '(:indent :binding-list :args (:slot-spec) :inline nil))
  1509.  
  1510. (setf (sedit:get-format 'defclass)
  1511.       '(:indent ((2) 1)
  1512.     :args (:keyword nil nil :slot-spec-list nil)
  1513.     :sublists (4)))
  1514.  
  1515. (setf (sedit:get-format 'defmethod)
  1516.       '(:indent ((2))
  1517.     :args (:keyword nil :lambda-list nil)
  1518.     :sublists (3)))
  1519.  
  1520. (setf (sedit:get-format 'defgeneric) 'defun)
  1521.  
  1522. (setf (sedit:get-format 'generic-flet) 'flet)
  1523.  
  1524. (setf (sedit:get-format 'generic-labels) 'flet)
  1525.  
  1526. (setf (sedit:get-format 'call-next-method)
  1527.       '(:indent (1) :args (:keyword nil)))
  1528.  
  1529. (setf (sedit:get-format 'symbol-macrolet) 'let)
  1530.  
  1531. (setf (sedit:get-format 'with-accessors)
  1532.       '(:indent ((1) 1)
  1533.     :args (:keyword :binding-list nil)
  1534.     :sublists (2)
  1535.     :miser :never))
  1536.  
  1537. (setf (sedit:get-format 'with-slots) 'with-accessors)
  1538.  
  1539. (setf (sedit:get-format 'make-instance)
  1540.       '(:indent ((1))
  1541.     :args (:keyword nil :slot-spec-list)))
  1542.  
  1543. (setf (sedit:get-format '*make-instance) 'make-instance)
  1544.  
  1545. ;;; PrettyFileIndex stuff, the product of Harley Davis.
  1546.  
  1547. (defvar *pfi-class-type* '(class defclass pfi-class-namer))
  1548.  
  1549. (defvar *pfi-method-type* '(method defmethod pfi-method-namer)
  1550.   "Handles method for prettyfileindex")
  1551.  
  1552. (defvar *pfi-index-accessors* nil
  1553.   "t -> each slot accessor gets a listing in the index.")
  1554.  
  1555. (defvar *pfi-method-index* :group
  1556.   ":group, :separate, :both, or nil")
  1557.  
  1558. (defun pfi-add-class-type ()
  1559.   (pushnew *pfi-class-type* il:*pfi-types*))
  1560.  
  1561. (defun pfi-add-method-type ()
  1562.   (pushnew *pfi-method-type* il:*pfi-types*))
  1563.  
  1564. (defun pfi-class-namer (expression entry)
  1565.   (let ((class-name (second expression)))
  1566.     ;; Following adds all slot readers/writers/accessors as separate entries in
  1567.     ;; the index.  Probably a mistake.
  1568.     (if *pfi-index-accessors*
  1569.     (let ((slot-list (fourth expression))
  1570.           (accessor-names nil))
  1571.       (labels ((add-accessor (method-index name-index)
  1572.              (push (case *pfi-method-index*
  1573.                  (:group method-index)
  1574.                  (:separate name-index)
  1575.                  ((t :both) (list method-index name-index))
  1576.                  ((nil) nil)
  1577.                  (otherwise (error "Illegal value for *pfi-method-index*: ~S"
  1578.                            *pfi-method-index*)))
  1579.                accessor-names))
  1580.            (add-reader (reader-name)
  1581.              (add-accessor `(method (,reader-name (,class-name)))
  1582.                    `(,reader-name (,class-name))))
  1583.            (add-writer (writer-name)
  1584.              (add-accessor `(method ((setf ,writer-name) (t ,class-name)))
  1585.                    `((setf ,writer-name) (t ,class-name)))))
  1586.         (dolist (slot-def slot-list)
  1587.           (do* ((rest-slot-args (cdr slot-def) (cddr rest-slot-args))
  1588.             (slot-arg (first  rest-slot-args)  (first rest-slot-args)))
  1589.            ((null rest-slot-args))
  1590.          (case slot-arg
  1591.           (:reader (add-reader (second rest-slot-args)))
  1592.           (:writer (add-writer (second rest-slot-args)))
  1593.           (:accessor (add-reader (second rest-slot-args))
  1594.                  (add-writer (second rest-slot-args)))
  1595.           (otherwise nil))))
  1596.         (cons `(class (,class-name)) accessor-names)))
  1597.     class-name)))
  1598.  
  1599. (defun pfi-method-namer (expression entry)
  1600.   (let ((method-name (second expression))
  1601.     (specializers nil)
  1602.     (qualifiers nil)
  1603.     lambda-list)
  1604.     (do* ((rest-qualifiers (cddr expression) (cdr rest-qualifiers))
  1605.       (qualifier (first rest-qualifiers) (first rest-qualifiers)))
  1606.      ((listp qualifier) (setq lambda-list qualifier)
  1607.                         (setq qualifiers (reverse qualifiers)) qualifiers)
  1608.       (push qualifier qualifiers))
  1609.     (do* ((rest-lambda-list lambda-list (cdr rest-lambda-list))
  1610.       (arg (first rest-lambda-list) (first rest-lambda-list)))
  1611.      ((or (member arg lambda-list-keywords) (null rest-lambda-list))
  1612.       (setq specializers (reverse specializers)))
  1613.       (push (if (listp arg) (second arg) t) specializers))
  1614.     (let ((method-index `(method (,method-name ,@qualifiers ,specializers)))
  1615.       (name-index `(,method-name ,@qualifiers ,specializers)))
  1616.       (case *pfi-method-index*
  1617.     (:group method-index)
  1618.     (:separate name-index)
  1619.     ((t :both) (list method-index name-index))
  1620.     ((nil) nil)
  1621.     (otherwise (error "Illegal value for *pfi-method-index*: ~S" *pfi-method-index*))))))
  1622.  
  1623. (defun pfi-install-pcl ()
  1624.   (pfi-add-method-type)
  1625.   (pfi-add-class-type))
  1626.  
  1627. (eval-when (eval load)
  1628.   (when (boundp (quote il:*pfi-types*))
  1629.     (pfi-install-pcl))
  1630.   )
  1631.  
  1632.